COMMENT ⊗   VALID 00014 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	.SBTTL SMALL BLOCK ALLOCATOR
C00006 00003	SMALL BLOCK DESCRIPTOR FORMAT
C00009 00004	ROUTINE MAPPTR,<ROUT>	
C00013 00005	ROUTINE MARKPH		
C00015 00006	ROUTINE CPFYSP,<SPC>
C00019 00007	ROUTINE CPFY
C00020 00008	ROUTINE SWEEP
C00023 00009	ROUTINE GC
C00024 00010	GETSBK & GETBLK
C00027 00011	FREBLK & FRESBK
C00029 00012	ROUTINE NEWSPC,<SZ,IDF,NPB,GCF,NMN,NPC>
C00031 00013	ROUTINE ADDBUF,<SPACE>
C00033 00014	ROUTINE FSINI
C00035 ENDMK
C⊗;
.SBTTL SMALL BLOCK ALLOCATOR
;Coded by RHT 9-Sept-1974

SMBDBG == 1	;WE ARE DEBUGGING

; Overview:
;	The basic idea is to break up large blocks of storage
;into smaller, fixed size blocks, and then administer them.
;The routines given here provide a facility whereby a user
;can have a number of different "spaces" of fixed size blocks.
;Each space is described by an approximately 10 word descriptor
;block.  All these descriptor blocks are linked together on
;a big chain (SIDLST), and each space is assumed to have
;asociated with it a unique 8-bit number (thus allowing up to
;256 spaces).  Each space descriptor owns a linked list
;of buffers, with each buffer containing a number of blocks.
;Each space may be either collectable or uncollectable.
;Any block may be released explicitly, although if the
;space is collectable, this may be unwise.  Also, collectable
;spaces are compactified by the garbage collector.
;As an efficiency measure, the first few indices (now, 1-10)
;are also kept in a table (SIDTBL).
;
;Blocks are allocated by the routines GETBLK & GETSBK:
;
;	MOV	#IDCODE,R0	;IDCODE IS THE 8-BIT CODE FOR A 
;	JSR	PC,GETBLK	;SPACE
;
;	MOV	#SPCDSC,R0	;SPCDSC IS ADDRESS OF THE SPACE 
;	JSR	PC,GETSBK	;DESCRIPTOR
;
;In either case, a pointer to a new block is returned in R0.
;If need be, the free space routine will call the garbage collector
;to get more space or (if the space is not collectable or
;garbage collection is disabled) it will call the large block
;routines to get another buffer.  If garbage collection fails
;to produce a goodly surplus of blocks for some space, then
;additional buffers of new blocks will be obtained.
;
;Each small block has the following format:
;		tag,,id		;tag is used in garbage collecting
;	r0 →→	word 0		;this is the word pointed to by getblk
;		:
;		word n
;
;blocks are zeroed before being returned.  Although this is sometimes
;a bit extra overhead, it does prevent bugs and avoids the necessity
;for explicit clears all over the place.
;
;Blocks are freed by the routines FREBLK & FRESBK:
;
;	MOV	BLOCK,R0	;POINT AT BLOCK TO KILL
;	JSR	PC,FREBLK
;
;	MOV	BLOCK,R0	;POINT AT BLOCK TO KILL
;	MOV	#SPCDSC,R1	;R1 POINTS AT SPACE DESCRIPTOR
;	JSR	PC,FRESBK
;
;The macro 
;	 SPC ID,MMRT,SZ,NPB,GCF,NMN,NPC
;(defined on next page) may be used to declare compiled-in space blocks.
;Please see the comment on routine MAPPTR for additional incstuctions
;for declaring spaces.
;SMALL BLOCK DESCRIPTOR FORMAT

	II == 0
	XX	IDFLAG	;ACTUALLY A BYTE -- GETS PUT IN ID PART OF TAG WORD
	XX	MAPRTN	;ROUTINE TO BE CALLED ON MARK
	XX	SIZE	;How many words for a value cell in this type block.
	XX	NPERB	;NUMBER OF BLOCKS PER BUFFER
	XX	GCFG	;SET IF THIS IS NOT A COLLECTABLE AREA
	XX	NMIN	;MIN NUMBER OF FREE BLOCKS TO BE RETURNED BY GC
	XX	NPCT	;MIN % OF FREE BLOCKS TO BE RETURNED BY GC
	XX	NXTSID	;NEXT BLOCK ON ID CHAIN 
	XX	FFREE	;FREE LIST
	XX	FSTBUF	;OLDEST BUFFER
	XX	LSTBUF	;NEWEST BUFFER
	XX	NALLOC	;NUMBER ALLOCATED
	XX	NFREE	;NUMBER FREE
	SPCHDR == II

;; EACH BUFFER
	II == 0
	XX	NXTBUF	;NEXT BUFFER
	XX	PRVBUF	;PREVIOUS BUFFER
	XX	LSTBLK	;ADDRESS OF LAST BLOCK IN THIS BUFFER
	XX	FSTBLK	;POINTS AT FIRST LOCN
	BUFHDR == II

;; EACH BLOCK
	II == 0
	TAG == -1	;≠0 MEANS INUSE (USED IN GC)
	TAGID == -2	;USED TO HOLD AN "ID" FOR THIS RECORD
	XX	WORD0	;FIRST DATA WORD

;;GC METHODS
	II == 0
	XX	METH	;ROUTINE TO CALL
	XX	NXTMTH	;NEXT ON CHAIN

.MACRO MMETH ROUT
	ROUT
	0
.ENDM

;;SPECIAL SPACES

SIDCNT == 0;

.MACRO SPC ID,MMRT,SZ,NPB,GCF,NMN,NPC
    .IFNDF ID
	SIDCNT==SIDCNT+1
	ID==SIDCNT
    .ENDC
	ID	;IDFLAG
	MMRT	;MAPRTN
	SZ	;SIZE
	NPB	;NPERB
	GCF	;GCFG
	NMN	;NMIN
	NP _In:B≥ 4(%In:b%~&⊂4PI@%n42J⊗∀hP%@%\2NR
,04(%In2N$∩V_4PI@%nt
22>_h(%@KZ:~J,(4):,r∩44Ph*6εDJ∩→↓ki↓E@KZ6εa∧J:∩⊗Bα&:RzαN&∩$∩04(hR66⊗$BMh%H$%n⎇::Mα
α2&N"α>→αl
J.&t9α6⊗$B>∩LhR≡∞>[P%@$HInN⊗"α&→α<→α&M∧z-α:⎇84*∞∧2f>-PI@$$KZN⊗Q∧J→α∞|jBε∞$J~&∞
"&>9∧JMα>Xh*N&$bNQhK$$%\b&NQ∧z→αN∧
∞∃αL!α
2|~.L4U~&∩R∀ah%@hP%:
dZ]α6
B&∩_hP2J>-"&:∃∧jεBB%⊃1rJ⎇*Qx$hQml4SYnJ>-!αRε\*Mᬬ~&:≡d)αBε∀
6⊗R-⊃↓"&rαIA%¬:"&∞Bα&Mα
αB>&u"⊗H4SYl&Rz↓α¬α≤jε21∧∩2>∞Zq↓α&"αJ⊗R-∩:M↓DJ9αIαIα¬α∧z&:R-⊃αZεe*∀4)[X&↑"L~!α&~αR=α∀)αNR⎇∩⊗⊃α∀
∞-αLqαR"*αB>&u"⊗Iα≤*218hQml4Ph)mm∧jεBB%⊃αJVu→α∩><qα¬αdJNQα|1↓
6
∩.&::α6⊗RDz∩M	αB66⊗$BM$4SYmα⊗~!α6-"">⊃∧JMαε≥~V6⊗"αR=α∀)αJ⊗≥α>:NL∩2∃α4zIαN|j∀4)[Yα
ε$~!α>2αB>&u"⊗JMr↓α~>∩α⊗ε∞BαB>&u"⊗IαM!α~&t"M1α
4)mZα6⊗RDz⊃αNDzV2⊃∧~ε21¬""∃α∀zVR&t)α6ε∀ZIA↓E2&¬αU~IαB~H4)mZα&∃1∧*ε∞!∧jεJ.Lr≥α6-"">⊃¬~">Vd!α"ε4)αR"*α~>Jhh)mlLj⊗R!PJJ⎇
f3'KO"βC?'w#↔IxhQml$M:"&2*αHn:,b1α∩xh)mlHH&
⊗<J84)[X$$&∪α⎇"IKX4)mXH$&*≥⊃αB
djεJ.∪↓l4)[X$$%E⊃&}IβX4)mXH$&Jz→s;↔G!βC?NsS↔IsX4)mXH$&⊗t!l4)[X$&J-"VJ9Xh)mlhQmmαl
J.Iαα∩⊗R-∩6&:-→αR"*αRfB*α>→α$B∃αJ,~>J⊃αB&∃α4J:∩M∧JRMα≥αε∞∀hQmmα$*N∞JMαR>Ir↓α&Q¬""⊗9∧">⊗M∧	4)[X$&*≥⊂&B
dα6εB∃"9!s∨βπ∂∃rH4)mZα~>I¬~Bε∞-→α↑"-∩∃αRD*J∃α
∩∃α:zαB>&u"⊗Iα≥*
~&,b∩M1¬""&M∧jεeα∀)α*V≥ 4)mZα6.J$R5↓"L)α¬αTjAα↓∩BJ→%αI9↓αL1αR"-∩∃αε∀)αB>LrR⊗I¬~V
~L*2∩MbαR"⊗ph)mm¬""∃αPRTN NEEDS TO BE MORE COMPLICATED:
;;
;;		IF TAG(R0) THEN RTS PC;
;;		JSR	PC,@2(RF);
;;		PUSH R;
;;		R←R0;
;;		∀ <field> | <field> is a pointer subfield of R DO
;;			BEGIN
;;			R0←<field>
;;			JSR	PC,MARKR0;
;;			<field>←R0;
;;			end;
;;		R0←R;
;;		POP R;
;;		RTS PC;
;;
;;Note:  it may be a good idea to change the conventions here a bit
;;	to (1) pass a pointer at a record pointer & (2) let markr0
;;	assume responsibility for storing the updated pointer.
;;	The advantage of such a course is that it allows iterative
;;	marking of long lists, thus avoiding possible pdl overflows.
;;	*********

;;MAPPTR:	;(IN CASE YOU HAD FORGOTTEN)
	MOV	R2,-(SP)	;
	MOV	MMETHS,R2	;LIST OF MARKING METHS
	BEQ	MAPRTS		;DONE??
MAPLP:	CALL	@METH(R2),<ROUT(RF)>
	MOV	NXTMTH(R2),R2	;NEXT METHOD
	BNE	MAPLP		;ITERATE
MAPRTS:	MOV	(SP)+,R2	;
	RTS	RF		;RETURN

MKRTJM:	JMP	@ROUT(RF)	;THIS IS THE APPROPRIATE 
				;MARKING INTRINSIC FOR CASES WHERE
				;THERE ARE NO POINTER SUBFIELDS

MARKR0:	TST	R0		;A NULL IS A NULL
	BEQ	MR0.X		;	IS A NULL
	JSR	PC,PTRSID	;GETS SPACE DESCRIPTOR INTO R1
	JSR	PC,@MAPRTN(R1)	;CALL APPROPRIATE MARKING INTRINSIC
MR0.X:	RTS	PC

;THE NEXT ROUTINE IS USED TO ADD A METHOD TO THE "MMETHS" LIST
LNKMTH:	MOV	MMETHS,NXTMTH(R0)
	MOV	R0,MMETHS
	RTS	PC
ROUTINE MARKPH		
	MOV	R2,-(SP)	;
	MOV	R3,-(SP)	;
	MOV	SIDLST,R2	;ALL SIZES
	BEQ	MKPHRT		;DONE ALREADY??
MKPH.1:	TST	GCFG(R2)	;A GC SPACE??
	BEQ	MKPH.AD		;NO, GO ON TO NEXT
	MOV	SIZE(R2),R3	;
	INC	R3		;ONE FOR TAG WORD
	ASL	R3		;WORDS TO BYTES
	MOV	FSTBUF(R2),R1	;CLEAR THIS BUFFER
MKP.02:	MOV	FSTBLK(R1),R0	;FIRST BLOCK
MKPH.2:	CMP	R0,LSTBLK(R1)	;DONE THIS BUFFER?
	BGT	MKPH.3		;IF SO, GO ON TO NEXT
	CLRB	TAG(R0)		;CLEAR TAG
	ADD	R3,R0		;BUMP POINTER TO NEXT
	BR	MKPH.2		;ITERATE
MKPH.3:	MOV	NXTBUF(R1),R1	;ON TO NEXT BUFFER
	BNE	MKP.02		;IF WE HAVE ONE
MKPH.AD:MOV	NXTSID(R2),R2	;GO ON TO NEXT SPACE
	BNE	MKPH.1		;

	CALL	MAPPTR,<#MKROUT> ;DO THE ACTUAL MARKING
	
MKPHRT:	MOV	(SP)+,R3	;RESTORE
	MOV	(SP)+,R2
	RTS	RF

MKROUT:	MOVB	#377,TAG(R0)	;
	RTS	PC		;

ROUTINE CPFYSP,<SPC>
;;
;; PERFORMS ALL DATA MOVING REQUIRED TO COMPACTIFY ONE SIZE SPACE
;;
	MOV	R2,-(SP)	;SAVE SOME ACS
	MOV	R3,-(SP)	;
	MOV	R4,-(SP)	;
	MOV	SPC(RF),R2	;SPACE DSCR
	MOV	FSTBUF(R2),R3	;OLDEST
	MOV	LSTBUF(R2),R4	;NEWEST
	JSR	PC,NXF.0	;NEXT FREE INTO 1
				;MAY MODIFY R3
	BEQ	CPFY.2		;NO FREE
	JSR	PC,NXR.0	;GET A RECORD TO MOVE
				;INTO R1 (MAY MUNCH R0)
	BEQ	CPFY.2		;
CPFY.1:	MOV	R1,-(SP)	;SAVE THESE
	MOV	R0,-(SP)	;
	MOVB	#377,TAG(R0)	;
	CLRB	TAG(R1)		;
	MOV	SIZE(R2),R2	;
CPYR:	MOV	(R1)+,(R0)+	;COPY RECORD
	DEC	R2		;COUNT DOWN
	BGT	CPYR		;DONE??
	MOV	SPC(RF),R2	;YES
	MOV	(SP)+,R0	;GET ACS BACK
	MOV	(SP)+,R1	;
	MOV	R0,WORD0(R1)	;POINT AT THIS ONE
	JSR	PC,NXF.NX	;NEXT FREE
	BEQ	CPFY.2
	JSR	PC,NXR.NX	;NEXT RECORD
	BNE	CPFY.1		;PROCESS THAT ONE
CPFY.2:
	MOV	(SP)+,R4	;
	MOV	(SP)+,R3	;
	MOV	(SP)+,R2
	RTS	RF

NXF.0:	MOV	FSTBLK(R3),R0	;FIND A FREE BLOCK
NXF.1:	TSTB	TAG(R0)		;FREE
	BEQ	NXF.4		;YES
NXF.NX:	ADD	SIZE(R2),R0	;LOOK AT NEXT
	ADD	SIZE(R2),R0	;ADD TWICE SINCE WANT TRUE ADDRESS
	TST	(R0)+		;ADD IN TAG WORD OFFSET
	CMP	R0,LSTBLK(R3)	;MORE TO TRY??
	BLE	NXF.1		;TRY AGAIN
	MOV	NXTBUF(R3),R3	;NEXT NEWEST BUFFER
	BEQ	NXF.3		;LOOK THERE
	CMP	R3,R4		;IF NOT TO THE R SUPPLIER
	BNE	NXF.0
NXF.3:	CLR	R0
NXF.4:	MOV	R0,R0		;GET FLAGS CORRECT
	RTS	PC


NXR.0:	MOV	FSTBLK(R4),R0	;FIND A FULL BLOCK
NXR.1:	TSTB	TAG(R0)		;FULL
	BNE	NXF.4		;YES
NXR.NX:	ADD	SIZE(R2),R0	;LOOK AT NEXT
	ADD	SIZE(R2),R0	;ADD TWICE SINCE WANT TRUE ADDRESS
	TST	(R0)+		;ADD IN TAG WORD OFFSET
	CMP	R0,LSTBLK(R4)	;MORE TO TRY??
	BLE	NXR.1		;TRY AGAIN
	MOV	PRVBUF(R4),R4	;NEXT NEWEST BUFFER
	BEQ	NXR.3		;LOOK THERE
	CMP	R3,R4		;IF NOT TO THE R SUPPLIER
	BNE	NXF.0
NXR.3:	CLR	R0
NXR.4:	MOV	R0,R0		;GET FLAGS CORRECT
	RTS	PC
ROUTINE CPFY
	MOV	R2,-(SP)	
	MOV	SIDLST,R2	;LIST OF ALL SIZES
	BEQ	CPFYXX		;NULL LIST??
CPFYLP:	TST	GCFG(R2)	;COLLECTABLE??
	BEQ	CPFYNX		;BR IF NOT
	CALL	CPFYSP,<R2>	;COMPACTIFY THIS SPACE
CPFYNX:	MOV	NXTSID(R2),R2
	BNE	CPFYLP
CPFYXX:	CALL	MAPPTR,<#MUNLNK> ;MUNCH ALL LINKS
	; **** HERE IS THE SPOT WHERE YOU SHOULD WORRY ABOUT
	;      GETTING RID OF EXCESS BUFFER BLOCKS ****
CPFYRT:	MOV	(SP)+,R2	;RETURN
	RTS	RF

MUNLNK:	MOV	(R0),R1		;CALLED WITH R0 →→ A PTR
	TST	TAG(R1)		;DID WE MOVE IT ??
	BNE	MUNRTS		;
	MOV	WORD0(R1),(R0)	;YES, PUT NEW POINTER IN PLACE
MUNRTS:	RTS	PC		;

ROUTINE SWEEP
	MOV	R2,-(SP)	;
	MOV	SIDLST,R2	;LIST OF SIZES
	BEQ	SWP.X
SWP.LP:	JSR	PC,SWP.		;GO SWEEP ONE AREA
	MOV	NXTSID(R2),R2	;ITERATE
	BNE	SWP.LP		;
SWP.X:	MOV	(SP)+,R2	;
	RTS	RF		;

ROUTINE SWEEP1,<SPCC>	
	MOV	R2,-(SP)	;SAVE REGISTERS
	MOV	SPCC(RF),R2	;GET A SPACE
	JSR	PC,SWP.		;SWEEP ONE AREA
SWP.XX:	MOV	(SP)+,R2	
	RTS	RF

SWP.:	TST	GCFG(R2)	;IS THIS SPACE FOR SWEEPING??
	BNE	SWP.00		;
	RTS	PC		;NO
SWP.00:	MOV	R3,-(SP)	;YES
	MOV	R4,-(SP)	;
	CLR	FFREE(R2)	;WILL BUILD A REAL FREE LIST
	CLR	NFREE(R2)	;SINCE WE WILL FIX COUNTS
	CLR	NALLOC(R2)	;
	MOV	FSTBUF(R2),R3	;OLDEST BUFFER
	BEQ	SWP.3		;IF ANY
	MOV	SIZE(R2),R4	;COMPUTE SIZE
	INC	R4		;IN BYTES OF WHOLE THING
	ASL	R4		;
SWP.01:	MOV	FSTBLK(R3),R0	;GET A BLK
SWP.1:	TSTB	TAG(R0)		;ALLOCATED?
	BEQ	SWP.1N		;NO
	INC	NALLOC(R2)	;YES
	BR	SWP.2
SWP.1N:	INC	NFREE(R2)	;LINK UP A FREE
	MOV	FFREE(R2),WORD0(R0)
	MOV	R0,FFREE(R2)
SWP.2:	ADD	R4,R0		;BUMP POINTER TO NEXT IN BUFFER
	CMP	R0,LSTBLK(R3)	;DONE BUFFER??
	BLE	SWP.1		;NO
	MOV	NXTBUF(R3),R3	;YES GO ON TO NEXT
	BNE	SWP.01		;IF THERE IS ONE
SWP.3:	CMP	NFREE(R2),NMIN(R2)	;NEED MORE??
	BGT	SWP.5		;AT LEAST HAVE MIN NUMBER
SWP.4:	CALL	ADDBUF,<R2>	;NO, ADD A BUFFER FULL
	BR	SWP.3		;AND TRY AGAIN
SWP.5:	MOV	NFREE(R2),R0	;SEE IF HIGH ENOUGH PERCENTAGE
	ADD	NALLOC(R2),R0	;OF FREES
	MUL	NPCT(R2),R0	; 
	DIV	#144,R0		; NPCT*(NFREE+NALLOC)/=100
	CMP	NFREE(R2),R0	;
	BGT	SWP.6		;IF DONT HAVE ENOUGH
	CALL	ADDBUF,<R2>	;GET A BUFFER LOAD
	BR	SWP.5		;AND TRY AGAIN
SWP.6:	MOV	(SP)+,R4	;RESTORE
	MOV	(SP)+,R3
	RTS	PC

ROUTINE GC
	CALL	MARKPH		;MARK EVERYONE
	TST	CPFYOK		;IF DONT WANT COMPACTIFICATION
	BEQ	SWPPIT		;THEN DONT DO IT
	CALL	CPFY		;COMPACTIFY
SWPPIT:	CALL	SWEEP		;SWEEP UP LOOSE GARBAGE
	RTS	RF
;GETSBK & GETBLK
;

GETSBK:	
;
;	MOV	[SIZE DESCRIPTOR],R0
;	JSR	PC,GETBLK
;	<RETURNS WITH A BLOCK IN R0>
;
	MOV	R0,R1			
GETBL1:	TST	R1			;ERROR TRAP
	BEQ	GETBER
	MOV	FFREE(R1),R0		;R0 ← FIRST FREE
	BNE	GETBLX			;DID WE GET ONE
	MOV	R1,-(SP)		;NO,
	TST	GCFG(R1)		;IS GC OK FOR THIS AREA?
	BEQ	GETADB			;NO, MUST ADD
	TST	GCOK			;IS GARBAGE COLLECTION OK AT ALL
	BNE	GETGC			;
GETADB:	CALL	ADDBUF,<R1>		;NO, JUST GET A BUFFER
	BR 	GETBXX			;
GETGC:	CALL	GC			;YES, GC
GETBXX:	MOV	(SP)+,R1		;
	BR	GETBL1
GETBLX:	MOV	WORD0(R0),FFREE(R1)	;NEW FREE LIST
	INC	NALLOC(R1)		;ADJUST COUNTS
	DEC	NFREE(R1)
	MOVB	IDFLAG(R1),TAGID(R0)	;REMEMBER WHAT IT IS
	MOV	R0,-(SP)		;SAVE POINTER TO BLOCK
	MOV	SIZE(R1),R1		;WORD COUNT
GETB.C:	CLR	(R0)+			;CLEAR A WORD
	DEC	R1			;COUNT DOWN
	BGT	GETB.C			;UNTIL DONE
	MOV	(SP)+,R0		;RETURN VALUE BACK
	RTS	PC

;
;	MOV	#ID,R0
;	JSR	PC,GETBLK
;
GETBLK:	JSR	PC,GETSID		;SET UP SPC DSCR IN R1
	BR	GETBL1

GETBER:	HALERR	GERMSG
	CLR	R0
	RTS	PC

GERMSG:	ASCIE	/ATTEMPT TO ALLOCATE RECORD WITHOUT GIVING DESCRIPTOR/

GETSID:	MOV	R0,R1
	CMP	R0,#MAXIDF		;IN THE TABLE?
	BGT	GETS.1			;NO
	ASL	R1
	MOV	SIDTBL(R1),R1		;YES
GETS.X:	RTS	PC			;
GETS.1:	MOV	SIDLST,R1		;SEARCH CHAIN
	BEQ	GETS.X
GETS.2:	CMP	R0,IDFLAG(R1)		;THIS ONE??
	BNE	GETS.X			;YES
	MOV	NXTSID(R1),R1		;NO, TRY NEXT
	BNE	GETS.2
	RTS	PC

PTRSID:	MOV	R0,-(SP)		;SINCE GETSID WILL MUNCH
	MOVB	TAGID(R0),R0		;THE ID FLAG
	JSR	PC,GETSID		;GET SID INTO R1
	MOV	(SP)+,R0		;GET PTR BACK
	RTS	PC
;FREBLK & FRESBK
;	MOV	BLK,R0
;	JSR	PC,FREBLK
;
FREBLK: MOV	SIDLST,R1	;FIND THE SPACE
	BEQ	FREBER		;THIS CAME FROM
FREB.1:	CMPB	TAGID(R0),IDFLAG(R1) ;WAS IT THIS AREA
	BNE	FREB.2		;NO
FREB.:	MOV	FFREE(R1),WORD0(R0);FOUND THE AREA, PUT ON FREE CHAIN
	MOV	R0,FFREE(R1)
	INC	NFREE(R1)	;ADJUST COUNTS
	DEC	NALLOC(R1)
	CLRB	TAG(R0)		;JUST FOR RANDOMNESS
	RTS	PC		;DONE
FREB.2:	MOV	NXTSID(R1),R1	;LOOK AT NEXT
	BNE	FREB.1		;ITERATE
FREBER:	HALERR	FRERMS
FRERMS:	ASCIE	/ATTEMPT TO DELETE A BLOCK FROM AN AREA I CANNOT FIND/
	RTS	PC

FRESBK:	CMPB	TAGID(R0),IDFLAG(R1)	;BE SURE THIS IS OK
	BEQ	FREB.		;WE WIN
	HALERR	FRBER2
	BR	FREB.		;DO IT ANYHOW IF CONTINUES IT

FRBER2:	ASCIE	/ID DISAGREEMENT FOR FRESBK/
ROUTINE NEWSPC,<SZ,IDF,NPB,GCF,NMN,NPC>

	MOV	#SPCHDR/2,R0	;GET A BLOCK OF CORE
	JSR 	PC,GTFREE
	MOV	SZ(RF),SIZE(R0) ;REMEMBER HOW BIG
	MOV	NPB(RF),NPERB(R0) ;
	MOV	IDF(RF),IDFLAG(R0) ;
	MOV	NMN(RF),NMIN(R0);
	MOV	NPC(RF),NPCT(R0);
NEWS.1:	MOV	SIDLST,NXTSID(R0)  ;LINK ONTO ID CHAIN
	MOV	R0,SIDLST
	MOV	IDFLAG(R0),R1	;WILL IT FIT IN ID CHAIN
	CMP	R1,#MAXIDF	;WILL IT FIT INTO TABLE
	BGT	NEWS.2		;
	ASL	R1		;YES
	MOV	R0,SIDTBL(R1)	;PUT INTO TABLE
NEWS.2:	CLR	FSTBUF(R0)	;ZEROE OUT OTHER THINGS
	CLR	LSTBUF(R0)	;
	CLR	NALLOC(R0)
	CLR	NFREE(R0)
	RTS	RF		;RETURN

ROUTINE SETSPC,<SPCHDR>
	MOV	SPCHDR(RF),R0	;
	BR	NEWS.1		;GO INITIALIZE ALL NON-CONSTANT THINGS
ROUTINE ADDBUF,<SPACE>
;ADDS ANOTHER BUFFER TO THE NAMED SPACE
	MOV	R2,-(SP)		;SAVE A REGISTER
	MOV	R3,-(SP)
	MOV	SPACE(RF),R2
	MOV	SIZE(R2),R1		;CALCULATE WORD REQUIREMENTS
	INC	R1			;ONE WORD OVERHEAD FOR TAG & ID BYTES
	MOV	R1,-(SP)		;WILL NEED THIS LATER
	MUL	NPERB(R2),R1		;SIZE*NUMBER OF BLOCKS
	ADD	#BUFHDR/2,R1		;
	MOV	R1,R0			;
	JSR	PC,GTFREE		;GET A BLOCK
	MOV	LSTBUF(R2),R1		;LINK ONTO CHAIN
	MOV	R1,PRVBUF(R0)		;LINK BACK
	BEQ	ADB.01			;
	MOV	R0,NXTBUF(R1)		;AND PERHAPS FORWARD
	BR	ADB.1			;
ADB.01:	MOV	R0,FSTBUF(R2)		;IF WAS NO LSTBUF, THEN THIS IS FSTBUF
ADB.1:	CLR	NXTBUF(R0)		;CLEAN UP
	MOV	R0,LSTBUF(R2)		;NEW NEWEST BLOCK
	MOV	R0,R3			;
	ADD	#2+BUFHDR,R3		;POINTER AT FIRST BLOCK
	MOV	R3,FSTBLK(R0)		;REMEMBER IT
	MOV	NPERB(R2),R1		;
	ASL	(SP)			;NUMBER OF BYTES TO STEP BY
	SUB	(SP),R3			;TO UNDO FIRST ADD

ADB.2:	ADD	(SP),R3
	INC	NFREE(R2)		;ONE MORE FREE
	CLRB	TAG(R3)			;CLEAR TAG
	MOVB	IDFLAG(R2),TAGID(R3)	;SET TYPE ID
	MOV	FFREE(R2),WORD0(R3)	;CONS ONTO FREE LIST
	MOV	R3,FFREE(R2)		;
	DEC	R1			;ITERATE
	BGT	ADB.2			;IF ANY LEFT

	MOV	R3,LSTBLK(R0)		;R3 NOW POINTS AT LAST BLOCK
	TST	(SP)+			;POP
	MOV	(SP)+,R3		;RESTORE ACS
	MOV	(SP)+,R2
	RTS	RF

ROUTINE FSINI
	CLR	SIDLST
	CLR	GCOK
	CLR	CPFYOK
	CLR	MMETHS
	CALL	SETSPC,<#VCTSPC>
	RTS	RF

.IFNZ	SMBDBG
VCTSPC:	SPC	VCTID,MKRTJM,4,10,1,4,15


FSTEST:	CALL	FSINI
	MOV	#20,R2
	MOV	#VCTARA,R3
FST.1:	MOV	#VCTID,R0
	JSR	PC,GETBLK
FST.2:	MOV	R0,(R3)+
	DEC	R2
	BGT	FST.1
FST.3:	MOV	#13,R2
FST.4:	MOV	-(R3),R0
	JSR	PC,FREBLK
	DEC	R2
	BGT	FST.4
FST.5:	MOV	#17,R2
FST.6:	MOV	#VCTID,R0
	JSR	PC,GETBLK
	MOV	R0,(R3)+
	DEC	R2
	BGT	FST.6
FST.10:	MOV	#TSTMTH,R0
	JSR	PC,LNKMTH
	MOV	R3,VCTUB
	SUB	#2,VCTUB
	MOV	#VCTARA,VCTLB
	MOV	#-1,GCOK
	CALL	GC
FST.11:	MOV	#10,R2
FST.12:	MOV	#VCTSPC,R0
	JSR	PC,GETSBK
	DEC	R2
	BGT	FST.12

	HALERR	DNMSG

DNMSG:	ASCIE	/
WELL HOW DID WE DO?/

VCTARA:	.BLKW	200
VCTUB:	0
VCTLB:	0

TSTMTH:	MMETH	TSTRTN

ROUTINE TSTRTN,<RTN>
	MOV	R2,-(SP)
	MOV	VCTLB,R2
TST.R1:	CMP	R2,VCTUB
	BGT	TSTRTS
	MOV	(R2),R0
	JSR	PC,MARKR0
	MOV	R0,(R2)+
	BR	TST.R1
TSTRTS:	MOV	(SP)+,R2
	RTS	RF

.ENDC